--{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Math
import RenderEngine
import StreamEngine

import Data.VectorSpace hiding (Scalar)
import qualified Data.Stream as S

import Control.Applicative
import Data.Maybe
import Data.Monoid

import qualified Data.IntSet as IntSet
import Data.IntSet (IntSet)

-------------------------------------------------------------------------------

data GameSample = GameSample { blockSet :: !IntSet
                             , gameLost  :: !Incident
                             , gameExit :: !Incident
                             }
                  deriving Show

type Game = Signal GameSample

--withBallPos :: Vector -> GameSample -> GameSample
--withBallPos v g = g { ballPos = v }

--withPaddlePos :: Vector -> GameSample -> GameSample
--withPaddlePos v g = g { paddlePos = v }

withGameLost :: Incident -> GameSample -> GameSample
withGameLost v g = g { gameLost = v }

withGameExit :: Incident -> GameSample -> GameSample
withGameExit v g = g { gameExit = v }

{-
withPicture :: Picture -> GameSample -> GameSample
withPicture v g = g { picture = v }
-}

-------------------------------------------------------------------------------

wallLeft   :: Scalar 
wallRight  :: Scalar 
wallBottom :: Scalar 
wallTop    :: Scalar 
wallSize   :: Scalar 
wallHeight :: Scalar 
wallWidth  :: Scalar 
ballRadius :: Scalar 

initBallSpeed :: Scalar 
initBallPos   :: Vector 
initPaddlePos :: Vector 

paddleWidth :: Scalar
paddleHeight :: Scalar

wallLeft   = worldMinX+10
wallRight  = worldMaxX-10
wallBottom = worldMinY+10
wallTop    = worldMaxY-10
wallSize   = 5
wallHeight = wallTop - wallBottom
wallWidth  = wallRight - wallLeft

ballRadius = 10

initBallSpeed = -200
initBallPos   = (0,0)
initPaddlePos = (0, wallBottom+50)

paddleWidth = 100
paddleHeight = 10

-------------------------------------------------------------------------------

isColliding :: Ordering -> Scalar -> Scalar -> Scalar -> Bool
isColliding ordering wall pos vel = 
  pos `compare` wall == ordering && 
  vel `compare` 0    == ordering

-------------------------------------------------------------------------------

gameExits :: Sensors -> Trigger
gameExits ss = eitherT (keyDowns (SpecialKey ESC) ss) $ 
                 bothT (rightButtonDowns ss) (leftButtonDowns ss)

-------------------------------------------------------------------------------

walls :: Picture
walls = mconcat [leftWall, rightWall, topWall, bottomWall]
    
leftWall :: Picture
leftWall = solidPolygonAt (wallLeft,0) (rgb 0 0 1) $
           rectPath wallSize wallHeight

rightWall :: Picture
rightWall =  solidPolygonAt (wallRight,0) (rgb 0 0 1) $
             rectPath wallSize wallHeight

topWall :: Picture
topWall =  solidPolygonAt (0,wallTop) (rgb 0 0 1) $
           rectPath wallWidth wallSize
              
bottomWall :: Picture
bottomWall = solidPolygonAt (0,wallBottom) (rgb 1 0 0) $
             rectPath wallWidth wallSize

-------------------------------------------------------------------------------

render :: Position -> Position -> Picture
render ballPos paddlePos = paddle `over` ball `over` walls
  where
    paddle = solidPolygonAt paddlePos (rgb 1 0 1) $
             rectPath paddleWidth paddleHeight

    ball = solidPolygonAt ballPos (rgb 1 1 0) $
           circlePath ballRadius 36


-------------------------------------------------------------------------------

type GameOutput = (GameSample,Picture)
type GameOutputs = Signal GameOutput

paddleDemo :: Sensors -> GameOutputs
paddleDemo ss = S.zip gs ps
  where
    gs = GameSample <$> gameLosts <*> gameExits ss
    ps = S.map (uncurry render) $ S.zip ballPositions paddlePositions 
    ballPositions   = S.zip ballPosX ballPosY
    paddlePositions = S.zip paddlePosX paddlePosY
    mp              = mousePositions ss
    dt              = tickDurations ss
    ballPosX        = integral (fst initBallPos) ballVelX dt
    ballPosY        = integral (snd initBallPos) ballVelY dt
    paddlePosX      = integral (fst initPaddlePos) paddleVelX dt
    paddlePosY      = pure (snd initPaddlePos)
    paddleVelX      = (fst <$> mp) ^-^ paddlePosX
    wallOffset      = wallSize + ballRadius
    ballColLeft     = isColliding LT (wallLeft+wallOffset)   
                      <$> ballPosX <*> ballVelX
    ballColRight    = isColliding GT (wallRight-wallOffset)  
                      <$> ballPosX <*> ballVelX 
    ballColBottom   = isColliding LT (wallBottom+wallOffset) 
                      <$> ballPosY <*> ballVelY 
    ballColTop      = isColliding GT (wallTop-wallOffset)    
                      <$> ballPosY <*> ballVelY 
    ballPaddleZoneY = snd initPaddlePos + paddleHeight/2 + ballRadius
    ballColPaddleY  = isColliding LT ballPaddleZoneY <$> ballPosY <*> ballVelY
    ballColPaddleX  = ballPosX ~>~ paddlePosX ^-^ pure (paddleWidth/2) ~&&~
                      ballPosX ~<~ paddlePosX ^+^ pure (paddleWidth/2)
    ballColPaddle   = ballColPaddleX ~&&~ ballColPaddleY
    ballVelX        = S.scan' bounce initBallSpeed  (ballColLeft ~||~ ballColRight)
    ballVelY        = S.scan' bounce initBallSpeed  
                      (ballColTop  ~||~ ballColBottom ~||~ ballColPaddle)
    bounce a b      = if b then negate a else a
    gameLosts       = edge $ (not <$> ballColPaddle) ~&&~ ballColBottom

-------------------------------------------------------------------------------

type SS = SensorsSample

sswitch :: forall a. Signal a -> Sensors -> 
           Event (a -> Sensors -> Signal a) ->
           Signal a
sswitch as ss es = S.map fst $ switch ass eas
  where
    ass = S.zip as ss
    eas = mapE aux es
      where
        aux :: (a -> Sensors -> Signal a) -> 
               (a,SS) -> Signal (a,SS) -> Signal (a,SS)
        aux f asp sasp = S.zip (f (fst asp) ss) ss
          where
            ss = S.map snd sasp

-------------------------------------------------------------------------------

gameLoop :: Sensors -> GameOutputs
gameLoop ss = sswitch gps ss (maybeGameOver `mergeE` maybeRestart)
  where
    gps = paddleDemo ss
    (gs,ps) = S.unzip gps
    maybeGameOver = mapT gameOver (gameLost <$> gs)
    maybeRestart  = mapT (const gameLoop) (rightButtonDowns ss)

gameOver :: GameOutput -> Sensors -> GameOutputs
gameOver (g,p) ss = sswitch gps ss maybeRestart
  where 
    gps = S.zip ((`withGameExit` g) <$> gameExits ss) (pure p)
    maybeRestart = mapT (const gameLoop) (leftButtonDowns ss)

game :: Sensors -> Pictures
game = map snd . S.takeWhile (isNothing . gameExit . fst) . gameLoop

-------------------------------------------------------------------------------

main :: IO ()
main = run game

z :: IO ()
z = main
